home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
pascal
/
tptc17sc.zip
/
TPCEXPR.INC
< prev
next >
Wrap
Text File
|
1988-03-26
|
18KB
|
760 lines
(*
* TPTC - Turbo Pascal to C translator
*
* (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
*
*)
(*
* expression parser
*
*)
function pterm: string; forward;
function iscall(var lv: string): boolean;
{see if the given lvalue is a function call or not}
begin
iscall := lv[length(lv)] = ')';
end;
procedure make_pointer(var expr: string);
{convert the expression into a pointer constant, if possible}
var
sym: symptr;
begin
case(expr[1]) of
'*':
begin
delete(expr,1,1);
exit;
end;
'a'..'z','A'..'Z','_':
begin {pass pointer to strings/arrays}
sym := locatesym(expr);
if (sym <> nil) and ((sym^.symtype = s_string) or
(sym^.suptype = ss_array)) then
begin
{null}
end
else
if expr[length(expr)-1] = '(' then {remove () from function calls}
dec(expr[0],2)
else
expr := '&' + expr;
end;
end;
end;
function isnumber(var lv: string): boolean;
{see if the given value is a literal number}
var
i: integer;
begin
for i := 1 to length(lv) do
case lv[i] of
'0'..'9','.': ;
else
isnumber := false;
exit;
end;
isnumber := true;
end;
procedure subtract_base(var expr: string; base: integer);
{subtract the specified base from the given expression;
use constant folding if possible}
begin
if base <> 0 then
if isnumber(expr) then
expr := itoa(atoi(expr) - base)
else
if base > 0 then
expr := expr + '-' + itoa(base)
else
expr := expr + '+' + itoa(-base);
end;
function exprtype: char;
{determine expression type and return the printf code for the type}
var
xt: char;
begin
case cexprtype of
s_char: xt := 'c';
s_file: xt := '@';
s_double: xt := 'f';
s_string: xt := 's';
s_bool: xt := 'b';
s_int: xt := 'd';
s_long: xt := 'D'; { calling routine should convert to "ld" }
else xt := '?';
end;
exprtype := xt;
end;
function strtype(ty: char): boolean;
{see if the expression is a string data type or not}
begin
case ty of
's','c': strtype := true;
else strtype := false;
end;
end;
function psetof: string;
{parse a literal set; returns the set literal translated into
the form: setof(.....)}
var
ex: string;
begin
ex := 'setof(';
if tok[1] <> ']' then
ex := ex + pterm;
while (tok = '..') or (tok[1] = ',') do
begin
if tok = '..' then
ex := ex + ',__,'
else
ex := ex + ',';
gettok;
ex := ex + pterm;
end;
if ex[length(ex)] <> '(' then
ex := ex + ',';
ex := ex + '_E)';
psetof := ex;
end;
function pterm: string;
{parse an expression term; returns the translated expression term;
detects subexpressions, set literals and lvalues(variable names)}
var
ex: string;
builtin: boolean;
begin
if debug_parse then write(' <term>');
if (toktype = identifier) and (cursym <> nil) then
builtin := cursym^.suptype = ss_builtin
else
builtin := false;
(* process pos(c,str) and pos(str,str) *)
if builtin and (tok = 'POS') then
begin
if debug_parse then write(' <pos>');
gettok; {consume the keyword}
if tok[1] <> '(' then
syntax('"(" expected (pterm.pos)');
gettok; {consume the (}
ex := pexpr;
if exprtype{(ex)} = 'c' then
ex := 'cpos(' + ex
else
ex := 'spos(' + ex;
gettok; {consume the ,}
ex := ex + ',' + pexpr;
gettok; {consume the )}
pterm := ex + ')';
cexprtype := s_int;
end
else
(* process chr(n) *)
if builtin and (tok = 'CHR') then
begin
if debug_parse then write(' <chr>');
gettok; {consume the keyword}
if tok[1] <> '(' then
syntax('"(" expected (pterm.chr)');
gettok; {consume the (}
ex := pexpr;
gettok; {consume the )}
if isnumber(ex) then
ex := numlit(atoi(ex))
else
ex := 'chr('+ex+')';
pterm := ex;
cexprtype := s_char;
end
else
(* translate NOT term into !term *)
if builtin and (tok = 'NOT') then
begin
if debug_parse then write(' <not>');
gettok;
pterm := '!' + pterm;
cexprtype := s_bool;
end
else
(* process port/memory array references *)
if builtin and ((tok = 'PORT') or (tok = 'PORTW') or
(tok = 'MEM') or (tok = 'MEMW')) then
begin
if debug_parse then write(' <port>');
if tok = 'PORT' then ex := 'inportb(' else
if tok = 'PORTW' then ex := 'inport(' else
if tok = 'MEM' then ex := 'peekb(' else
ex := 'peek(';
gettok; {consume the keyword}
gettok; {consume the [ }
repeat
ex := ex + pexpr;
if tok[1] = ':' then
begin
gettok;
ex := ex + ',';
end;
until (tok[1] = ']') or recovery;
gettok; {consume the ] }
pterm := ex + ')';
cexprtype := s_int;
end
else
(* translate bitwise not (mt+) *)
if (tok[1] = '?') or (tok[1] = '~') or (tok[1] = '\') then
begin
if debug_parse then write(' <bitnot>');
gettok;
pterm := '!' + pterm; {what is a bitwise NOT in c?}
end
else
(* process unary minus *)
if tok = '-' then
begin
if debug_parse then write(' <unary>');
gettok;
pterm := '-' + pterm;
end
else
(* translate address-of operator *)
if tok[1] = '@' then
begin
if debug_parse then write(' <ref>');
gettok; {consume the '@'}
ex := plvalue;
make_pointer(ex);
pterm := ex;
end
else
(* pass numbers *)
if toktype = number then
begin
if debug_parse then write(' <number>');
pterm := tok;
gettok;
cexprtype := s_int;
end
else
(* pass strings *)
if toktype = strng then
begin
if debug_parse then write(' <string>');
pterm := tok;
gettok;
cexprtype := s_string;
end
else
(* pass characters *)
if toktype = chars then
begin
if debug_parse then write(' <char>');
pterm := tok;
gettok;
cexprtype := s_char;
end
else
(* pass sub expressions *)
if tok[1] = '(' then
begin
if debug_parse then write(' <subexp>');
gettok;
pterm := '(' + pexpr + ')';
gettok;
end
else
(* translate literal sets *)
if tok[1] = '[' then
begin
if debug_parse then write(' <setlit>');
gettok;
pterm := psetof;
gettok;
cexprtype := s_struct;
end
(* otherwise the term will be treated as an lvalue *)
else
pterm := plvalue;
end;
function pexpr: string;
{top level expression parser; parse and translate an expression and
return the translated expr}
var
ex: string;
ty: char;
ex2: string;
ty2: char;
procedure relop(newop: string40);
begin
if debug_parse then write(' <relop>');
gettok; {consume the operator token}
ex2 := pterm; {get the second term}
ty2 := exprtype;
{use strcmp if either param is a string}
if ty = 's' then
begin
if ty2 = 's' then
ex := 'strcmp(' + ex + ',' + ex2 + ') ' + newop + ' 0'
else
if ex2[1] = '''' then
ex := 'strcmp(' + ex + ',"' +
copy(ex2,2,length(ex2)-2) + '") ' + newop + ' 0'
else
ex := 'strcmp(' + ex + ',ctos(' + ex2 + ')) ' + newop + ' 0'